home *** CD-ROM | disk | FTP | other *** search
/ Acorn RISC PD-CD 1 / Acorn RISC PD-CD 1.iso / languages / _tile / f83 / ranges < prev    next >
Encoding:
Text File  |  1991-08-15  |  2.7 KB  |  121 lines
  1. \
  2. \  INTEGER RANGE LIBRARY
  3. \
  4. \  Copyright (C) 1988-1990 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 30 June 1988
  15. \
  16. \  Last updated on: 23 July 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth, blocks, structures
  20. \
  21. \  Description:
  22. \       Allows definition and manipulation of integer ranges.
  23. \
  24. \  Copying:
  25. \       This program is free software; you can redistribute it and\or modify
  26. \       it under the terms of the GNU General Public License as published by
  27. \       the Free Software Foundation; either version 1, or (at your option)
  28. \       any later version.
  29. \
  30. \       This program is distributed in the hope that it will be useful,
  31. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  32. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  33. \       GNU General Public License for more details.
  34. \
  35. \       You should have received a copy of the GNU General Public License
  36. \       along with this program; see the file COPYING.  If not, write to
  37. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  38.  
  39. .( Loading Ranges definitions...) cr
  40.  
  41. #include <Tile$Lib>.blocks
  42. #include <Tile$Lib>.structures
  43.  
  44. vocabulary ranges ( -- )
  45.  
  46. blocks structures ranges definitions
  47.  
  48. struct.type RANGE ( -- range)
  49.   long +to ( range -- addr) private
  50.   long +from ( range -- addr) private
  51. struct.end
  52.  
  53. : range ( from to -- )
  54.   create , ,
  55. does> ( range -- from to)
  56.   2@
  57. ;
  58.  
  59. : ?member-range ( x from to -- bool)
  60.   ?within
  61. ;
  62.  
  63. : ?intersection-range ( from1 to1 from2 to2 -- bool)
  64.   -rot < >r swap < r> or not
  65. ;
  66.  
  67. : size-range ( from to -- int)
  68.   swap - 1+                            
  69. ;
  70.  
  71. : union-range ( from1 to1 from2 to2 -- from3 to3)
  72.   rot max >r min r>
  73. ;
  74.  
  75. : intersection-range ( from1 to1 from2 to2 -- from3 to3)
  76.   rot min >r max r>
  77. ;
  78.  
  79. : map-range ( from to block[index -- ] -- )
  80.   swap 1+ rot do
  81.     i swap dup >r call r>
  82.   loop
  83.   drop
  84. ;
  85.  
  86. : ?map-range ( from to block[index -- bool] -- )
  87.   swap 1+ rot do
  88.     i swap dup >r call r> swap
  89.     if leave then
  90.   loop
  91.   drop
  92. ;
  93.  
  94. : .range ( from to -- )
  95.   ." [" swap 0 .r ." .." 0 .r ." ] "
  96. ;
  97.  
  98. : ?range ( str -- [from to true] or [str false])
  99.   >r 0 r@ dup c@ ascii [ =
  100.   if 1+ dup c@ ascii - =
  101.     if 1+ convert swap negate swap
  102.     else convert then
  103.     dup c@ ascii . = over c@ ascii . = and   
  104.     if 0 swap 2+ dup c@ ascii - =
  105.       if 1+ convert swap negate swap
  106.       else convert then
  107.       dup c@ ascii ] = swap 1+ c@ 0= and
  108.       if 2dup > not 
  109.        if r> drop compiling
  110.          if swap [compile] literal then
  111.          true exit
  112.        then
  113.       then
  114.     then
  115.   then
  116.   2drop r> false
  117. ; recognizer
  118.  
  119. forth only
  120.  
  121.